home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Amiga Collections: Bavarian
/
Bavarian #176 (19xx)(APS Electronic).zip
/
Bavarian #176 (19xx)(APS Electronic).adf
/
Tetriz2
/
MiniTetriz.imp
< prev
next >
Wrap
Text File
|
1988-08-09
|
9KB
|
398 lines
DEFINITION MiniTetriz; END MiniTetriz.
IMPLEMENTATION MiniTetriz;
IMPORT I: Intuition,
g: Graphics,
e: Exec,
d: Dos,
r: Random,
au: Audio,
es: ExecSupport;
CONST
W = 4; (* Spielfeldgröße *)
H = 20;
bw = 20; (* Boxgröße *)
bh = 8;
w = bw*W; (* Fenstergröße *)
h = bh*H;
TYPE
LS = LONGSET;
VAR
S: ARRAY 7,4 OF LONGSET; (* LONGSET = ARRAY 4,4 OF BOOLEAN *)
Feld: ARRAY W,H OF INTEGER;
nw: I.NewWindow;
window: I.WindowPtr;
rp: g.RastPortPtr;
MyMsgPtr: I.IntuiMessagePtr;
MyMsg: I.IntuiMessage;
Lines: INTEGER;
HiScore: INTEGER;
CONST (* $DataChip+ *)
RectTable = "\x7F\x80";
RectTableSize = 2;
AllocationMap = "\x01\x08\x02\x04";
VAR
AllocPort: e.MsgPortPtr;
AllocIOB: au.IOAudio;
AudioOpen: BOOLEAN;
(*-------------------------------------------------------------------------*)
PROCEDURE Box(x,y,c: INTEGER);
BEGIN
IF (x>=0) AND (y>=0) THEN
g.SetAPen(rp,c);
x := x*bw; y := y*bh;
g.RectFill(rp,x+1,y+1,x+(bw-2),y+(bh-1));
END;
END Box;
PROCEDURE Collide(s: LONGSET; x,y: INTEGER): BOOLEAN;
VAR i,j: INTEGER;
BEGIN
IF (y<0) OR (x<0) THEN RETURN FALSE END;
i := 0;
REPEAT
j := 0;
REPEAT
IF 4*i+j IN s THEN
IF (x+j>=W) OR (y+i>=H) OR (Feld[x+j,y+i]#0) THEN RETURN TRUE END;
END;
INC(j);
UNTIL j=4;
INC(i);
UNTIL i=4;
RETURN FALSE;
END Collide;
PROCEDURE Add(s: LONGSET; x,y,c: INTEGER);
VAR i,j: INTEGER;
BEGIN
i := 0;
REPEAT
j := 0;
REPEAT
IF 4*i+j IN s THEN Feld[x+j,y+i] := c END;
INC(j);
UNTIL j=4;
INC(i);
UNTIL i=4;
END Add;
PROCEDURE Draw(s: LONGSET; x,y,c: INTEGER);
VAR i,j: INTEGER;
BEGIN
i := 0;
REPEAT
j := 0;
REPEAT
IF 4*i+j IN s THEN
CASE x+j OF 0..W-1: CASE y+i OF 0..H-1: Box(x+j,y+i,c) ELSE END ELSE END;
END;
INC(j);
UNTIL j=4;
INC(i);
UNTIL i=4;
END Draw;
PROCEDURE WriteInt(i: INTEGER);
VAR
s: ARRAY 4 OF CHAR;
c: INTEGER;
BEGIN
c := 0;
REPEAT
s[3-c] := CHR(30H + i MOD 10);
i := i DIV 10;
INC(c);
UNTIL c=4;
g.SetAPen(rp,1); g.SetBPen(rp,0); g.SetDrMd(rp,g.jam2);
g.Text(rp,ADR(s),4);
END WriteInt;
PROCEDURE CheckLine();
VAR
x,y,y2: INTEGER;
lines: ARRAY H OF INTEGER;
lcnt: INTEGER;
BEGIN
lcnt := 0;
y := 0;
REPEAT
x := 0;
LOOP
IF Feld[x,y]=0 THEN EXIT END;
INC(x);
IF x=W THEN lines[lcnt] := 8*y; INC(lcnt); EXIT END;
END;
INC(y);
UNTIL y=H;
IF lcnt#0 THEN
INC(Lines,lcnt);
g.Move(rp,0,h+8); WriteInt(Lines);
es.BeginIO(ADR(AllocIOB));
g.SetDrMd(rp,g.complement);
x := 0;
REPEAT
y := 0;
REPEAT
g.RectFill(rp,0,lines[y]+1,w-1,lines[y]+7);
INC(y);
UNTIL y=lcnt;
INC(x);
d.Delay(3);
UNTIL x=8;
g.SetDrMd(rp,g.jam1);
e.WaitIO(ADR(AllocIOB));
y := 19; y2 := 19; DEC(lcnt);
WHILE y2>=0 DO
WHILE (lcnt>=0) AND (lines[lcnt]=8*y2) DO DEC(y2); DEC(lcnt) END;
x := 0;
REPEAT
Feld[x,y] := Feld[x,y2];
INC(x);
UNTIL x=W;
DEC(y); DEC(y2);
END;
WHILE y>=0 DO
x := 0;
REPEAT
Feld[x,y] := 0;
INC(x);
UNTIL x=W;
DEC(y)
END;
y := 0;
REPEAT
x := 0;
REPEAT
Box(x,y,Feld[x,y]);
INC(x);
UNTIL x=W;
INC(y);
UNTIL y=H;
END;
END CheckLine;
PROCEDURE Play(): BOOLEAN; (* TRUE wenn Q gedrückt *)
VAR
Stein: INTEGER;
x,x2,y,y2,c: INTEGER;
TimeCnt: INTEGER;
Turn,NewTurn: INTEGER;
BEGIN
g.SetAPen(rp,0);
g.RectFill(rp,0,0,w,h);
x := 0;
REPEAT
y := 0;
REPEAT
Feld[x,y] := 0;
INC(y);
UNTIL y=H;
INC(x);
UNTIL x=W;
Lines := 0; TimeCnt := 0;
REPEAT
Stein := r.RND(7); c := Stein MOD 3 + 1; Turn := 0;
x := W DIV 2 - 1; IF Stein=0 THEN DEC(x) END;
y := 0;
LOOP
IF Collide(S[Stein,Turn],x,y) THEN EXIT END;
Draw(S[Stein,Turn],x,y-1,0);
Draw(S[Stein,Turn],x,y,c);
LOOP
Draw(S[Stein,Turn],x,y,c);
IF TimeCnt>=300 THEN DEC(TimeCnt,300); EXIT END;
REPEAT
e.WaitPort(window.userPort);
MyMsgPtr := LONGINT(e.GetMsg(window.userPort));
UNTIL MyMsgPtr#NIL;
MyMsg := MyMsgPtr^;
e.ReplyMsg(MyMsgPtr);
IF I.intuiTicks IN MyMsg.class THEN INC(TimeCnt,30+Lines) END;
IF I.vanillaKey IN MyMsg.class THEN
Draw(S[Stein,Turn],x,y,0);
CASE MyMsg.code OF
ORD('4'):
IF (x>0) AND NOT Collide(S[Stein,Turn],x-1,y) THEN DEC(x) END |
ORD('5'):
NewTurn := (Turn + 1) MOD 4;
x2 := x; y2 := y;
IF Stein=0 THEN
IF ODD(Turn) THEN DEC(x2); INC(y2); ELSE INC(x2); DEC(y2) END;
END;
IF NOT Collide(S[Stein,NewTurn],x2,y2) THEN
Turn := NewTurn;
x := x2;
y := y2;
END |
ORD('6'):
IF NOT Collide(S[Stein,Turn],x+1,y) THEN INC(x) END |
ORD(' '):
LOOP
Draw(S[Stein,Turn],x,y,c);
IF Collide(S[Stein,Turn],x,y+1) THEN EXIT END;
d.Delay(1);
INC(y);
Draw(S[Stein,Turn],x,y-1,0);
END;
EXIT |
ORD('q'): RETURN TRUE |
ELSE END;
END;
IF I.closeWindow IN MyMsg.class THEN RETURN TRUE END;
END;
INC(y);
END;
IF y>0 THEN
Add(S[Stein,Turn],x,y-1,c);
CheckLine;
END;
UNTIL y=0;
IF Lines>HiScore THEN HiScore := Lines END;
d.Delay(30);
RETURN FALSE;
END Play;
(*-------------------------------------------------------------------------*)
BEGIN
window := NIL; HiScore := 0; AllocPort := NIL; AudioOpen := FALSE;
S[0,0] := LS{0..3}; S[0,1] := LS{0,4,8,12}; S[0,2] := LS{0..3}; S[0,3] := LS{0,4,8,12};
S[1,0] := LS{0..2,5}; S[1,1] := LS{0,4,5,8}; S[1,2] := LS{1,4..6}; S[1,3] := LS{1,4,5,9};
S[2,0] := LS{0..2,4}; S[2,1] := LS{0,4,8,9}; S[2,2] := LS{2,4..6}; S[2,3] := LS{0,1,5,9};
S[3,0] := LS{0..2,6}; S[3,1] := LS{0,1,4,8}; S[3,2] := LS{0,4..6}; S[3,3] := LS{1,5,8,9};
S[4,0] := LS{0,1,5,6}; S[4,1] := LS{1,4,5,8}; S[4,2] := LS{0,1,5,6}; S[4,3] := LS{1,4,5,8};
S[5,0] := LS{1,2,4,5}; S[5,1] := LS{0,4,5,9}; S[5,2] := LS{1,2,4,5}; S[5,3] := LS{0,4,5,9};
S[6,0] := LS{0,1,4,5}; S[6,1] := LS{0,1,4,5}; S[6,2] := LS{0,1,4,5}; S[6,3] := LS{0,1,4,5};
(*------ Open Audio-Device: ------*)
AllocPort := es.CreatePort(NIL,0);
IF AllocPort=NIL THEN HALT(0) END;
AllocIOB.request.message.node.pri := -40;
AllocIOB.request.message.replyPort := AllocPort;
AllocIOB.data := ADR(AllocationMap);
AllocIOB.length := 4;
IF (e.OpenDevice(ADR("audio.device"),0,ADR(AllocIOB),0)#0) OR
(AllocIOB.request.error = au.allocFailed)
THEN HALT(0) END;
AudioOpen := TRUE;
AllocIOB.request.command := e.write;
AllocIOB.request.flags := SHORTSET{4};
AllocIOB.data := ADR(RectTable);
AllocIOB.length := RectTableSize;
AllocIOB.period := 4000;
AllocIOB.cycles := 200;
AllocIOB.volume := 64;
(*------ Open Window: ------*)
nw.leftEdge := (g.gfx.normalDisplayColumns - (w+ 8)) DIV 2;
nw.topEdge := (g.gfx.normalDisplayRows - (h+24)) DIV 2;
nw.blockPen := 1;
nw.width := w+8;
nw.height := h+24;
nw.idcmpFlags := LONGSET{I.closeWindow,I.vanillaKey,I.intuiTicks};
nw.flags := LONGSET{I.windowClose,I.windowDepth,I.windowDrag,I.gimmeZeroZero,I.activate};
nw.screen := NIL;
nw.type := {I.wbenchScreen};
nw.title := NIL;
window := I.OpenWindow(nw);
IF window=NIL THEN HALT(0) END;
rp := window.rPort;
(*------ Start: ------*)
LOOP
g.SetAPen(rp,0); g.SetDrMd(rp,g.jam1);
g.RectFill(rp,0,0,w,h);
g.SetAPen(rp,1);
g.Move(rp, 0, 20); g.Text(rp,ADR("MiniTetriz"),10);
g.Move(rp, 0, 40); g.Text(rp,ADR("S = Start "),10);
g.Move(rp, 0, 60); g.Text(rp,ADR("Q = Quit "),10);
g.Move(rp, 0, 80); g.Text(rp,ADR(" © 1989 "),10);
g.Move(rp, 0,100); g.Text(rp,ADR(" AMOK "),10);
g.Move(rp, 0,h+48); g.Text(rp,ADR("H0000"),5);
g.Move(rp,48,h+8); WriteInt(HiScore);
REPEAT
REPEAT
e.WaitPort(window.userPort);
MyMsgPtr := LONGINT(e.GetMsg(window.userPort));
UNTIL MyMsgPtr#NIL;
MyMsg := MyMsgPtr^;
e.ReplyMsg(MyMsgPtr);
UNTIL LONGSET{I.intuiTicks}#MyMsg.class;
IF I.vanillaKey IN MyMsg.class THEN
CASE MyMsg.code OF
ORD('s'): IF Play() THEN EXIT END |
ORD('q'): EXIT |
ELSE END;
ELSIF I.closeWindow IN MyMsg.class THEN
EXIT
END;
END;
CLOSE
IF window#NIL THEN I.CloseWindow(window) END;
IF AudioOpen THEN e.CloseDevice(ADR(AllocIOB)) END;
IF AllocPort#NIL THEN es.DeletePort(AllocPort) END;
END MiniTetriz.